home *** CD-ROM | disk | FTP | other *** search
/ ADA Programming Guide / ADA Programming Guide.iso / ada_gwu / inta.c < prev    next >
C/C++ Source or Header  |  1996-01-30  |  51KB  |  2,255 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9.  
  10. /* interpreter procedures - interpreter part a */
  11.  
  12.  
  13. /* Include standard header modules */
  14. #include <stdio.h>
  15. #include <stdlib.h>
  16. #include "config.h"
  17. #include "int.h"
  18. #include "ivars.h"
  19. #include "farithp.h"
  20. #include "predefp.h"
  21. #include "machinep.h"
  22. #include "taskingp.h"
  23. #include "imiscp.h"
  24. #include "intbp.h"
  25. #include "intcp.h"
  26. #include "intap.h"
  27.  
  28. static int main_loop();
  29. static int get_word();
  30. #ifdef DEBUG_INT
  31. static void zbreak(int);
  32. #endif
  33.  
  34. #define TRACE
  35. /* MAIN PROGRAM */
  36.  
  37. #ifdef DEBUG_STORES
  38. int *heap_store_addr;
  39. /* set heap_store_offset non zero to trace stores to that offset
  40.  * in primary heap 
  41.  */
  42. extern int heap_store_offset;
  43. int heap_store_now=0;
  44. #endif
  45.  
  46. int int_main()                                                /*;int_main*/
  47. {
  48.     int        status;
  49.  
  50.     reset_clock();
  51.     num_cunits = 0;
  52.  
  53.     /* Memory initialization, allocate primary heap segment. */
  54.  
  55.     if(!allocate_new_heap()) {
  56.         fprintf(stderr,"Unable to allocate primary heap\n");
  57.         exit(RC_ABORT);
  58.     }
  59.  
  60.     /* Initialize working template for fixed point arithmetic */
  61.  
  62.     *heap_next++ = 1 + WORDS_PTR + WORDS_FX_RANGE;
  63.     heap_next += WORDS_PTR;
  64.     temp_template = FX_RANGE(heap_next);
  65.     temp_template->ttype = TT_FX_RANGE;
  66.     temp_template->object_size = 2;
  67.     temp_template->small_exp_2 = 0;
  68.     temp_template->small_exp_5 = 0;
  69.     temp_template->fxlow = MIN_LONG;
  70.     temp_template->fxhigh = MAX_LONG;
  71.     heap_next += WORDS_FX_RANGE;
  72.  
  73.     /* Other initialization */
  74.  
  75.     sfp = bfp = 0;
  76.     initialize_predef();
  77.     initialize_tasking();
  78.  
  79.     /* Perform the main loop of the interpretor(terminates at end of pgm) */
  80.  
  81.     status = main_loop();
  82.  
  83.     /* Termination processing */
  84.  
  85.     predef_term();
  86.  
  87.     return status;
  88. }
  89.  
  90. /*
  91.  *  MAIN LOOP
  92.  *  =========
  93.  */
  94.  
  95. /*
  96.  *  GET_BYTE        Next code byte (char), IP is incremented
  97.  *  GET_WORD        Next code word (int), IP is incremented
  98.  *  GET_GAD(bse,off)    Get base/offset from code, IP incremented
  99.  *  GET_LAD(bse,off)    Get local addr from code, and get corr global addr
  100.  */
  101. #define GET_BYTE      (0xff & (int)cur_code[ip++])
  102. #ifdef ALIGN_WORD
  103. #define GET_WORD      (w=get_word(), w)
  104. #else
  105. #define GET_WORD          (w = *((int *)(cur_code+ip)), ip += sizeof(int), w)
  106. #endif
  107. #define GET_GAD(bse,off)  bse=GET_BYTE,off=GET_WORD
  108. #define GET_LAD(bse,off)  sp=GET_WORD+sfp,bse=cur_stack[sp],off=cur_stack[sp+1]
  109.  
  110. static int main_loop()                                            /*;main_loop*/
  111. {
  112. #ifdef DEBUG_INT
  113.     int     iparg;
  114. #endif
  115. #ifdef ALIGN_WORD
  116.     /* auxiliary procedures if must unpack from code stream byte by byte */
  117. #endif
  118.  
  119.     /* General purpose work locations */
  120.  
  121.     /* Loop through instructions */
  122.  
  123.     for (;;) {
  124.  
  125. #ifdef GWUMON
  126.         /*  Calculate task timing for each task, one tick is one */
  127.         /*  pass through the loop */
  128.  
  129.         CWK_TIME_TASK();
  130. #endif
  131.         /* Simulate the Clock Interrupt */
  132.  
  133.         if (next_clock_flag &&(next_clock <(now_time = itime() + time_offset)))
  134.             clock_interrupt(now_time);
  135.  
  136.         /* Round-robin scheme: next task's turn ? */
  137.  
  138.         if (rr_flag && (rr_counter++ > rr_nb_max_stmts))
  139.             round_robin();
  140.  
  141. #ifdef DEBUG_INT
  142. #ifdef DEBUG_STORES
  143.         if (heap_store_offset!=0 && 
  144.           heap_store_now != heap_store_addr[heap_store_offset]) {
  145.             printf("heap stores change %d from %d to %d\n",
  146.               heap_store_offset, heap_store_now, 
  147.               heap_store_addr[heap_store_offset]);
  148.             heap_store_now = heap_store_addr[heap_store_offset];
  149.         }
  150. #endif
  151.         iparg = ip;
  152.         if (instruction_trace)
  153.             i_list1(&iparg, cur_code);        /* debug */
  154.         if(break_point && (ip >= break_point))
  155.             zbreak(0);
  156. #endif
  157.         /* Get next opcode, bump instruction pointer and switch to routine */
  158.         switch(GET_BYTE) {
  159.  
  160.         case I_NOP:
  161.             break;
  162.  
  163.             /* Instructions Dealing with Tasking */
  164.  
  165.         case I_ABORT:
  166.             value = GET_WORD;            /* number of tasks in stack */
  167.             abort(value);
  168.             break;
  169.  
  170.         case I_ACTIVATE:
  171.             if (BLOCK_FRAME->bf_tasks_declared != 0) {
  172.                 value = pop_task_frame();
  173.                 start_activation(value, tp, bfp);
  174.                 /* master is current block frame */
  175.             }
  176.             break;
  177.  
  178.         case I_ACTIVATE_NEW_L:
  179.             GET_LAD(bse, off);
  180.             if (BLOCK_FRAME->bf_tasks_declared != 0) {
  181.                 value = pop_task_frame();
  182.                 ptr = ADDR(bse, off);
  183.                 start_activation(value, ACCESS(ptr)->master_task, 
  184.                   ACCESS(ptr)->master_bfp);
  185.             }
  186.             break;
  187.  
  188.         case I_ACTIVATE_NEW_G:
  189.             GET_GAD(bse, off);
  190.             if (BLOCK_FRAME->bf_tasks_declared != 0) {
  191.                 value = pop_task_frame();
  192.                 ptr = ADDR(bse, off);
  193.                 start_activation(value, ACCESS(ptr)->master_task, 
  194.                   ACCESS(ptr)->master_bfp);
  195.             }
  196.             break;
  197.  
  198.         case I_CREATE_TASK_G:
  199.             GET_GAD(bse, off);
  200.             start_creation(bse, off);
  201.             break;
  202.  
  203.         case I_CREATE_TASK_L:
  204.             GET_LAD(bse, off);
  205.             start_creation(bse, off);
  206.             break;
  207.  
  208.         case I_POP_TASKS_DECLARED_G:
  209.             GET_GAD(bse, off);
  210.             if (BLOCK_FRAME->bf_tasks_declared != 0)
  211.                 value = pop_task_frame();
  212.             else
  213.                 value = 0;
  214.             *ADDR(bse, off) = value;
  215.             break;
  216.  
  217.         case I_POP_TASKS_DECLARED_L:
  218.             GET_LAD(bse, off);
  219.             if (BLOCK_FRAME->bf_tasks_declared != 0)
  220.                 value = pop_task_frame();
  221.             else
  222.                 value = 0;
  223.             *ADDR(bse, off) = value;
  224.             break;
  225.  
  226.         case I_LINK_TASKS_DECLARED:
  227.             POP(value);
  228.             push_task_frame(value);
  229.             break;
  230.  
  231.         case I_CURRENT_TASK:
  232.             PUSH(tp);
  233.             break;
  234.  
  235.         case I_END_ACTIVATION:
  236.             value = GET_BYTE;
  237.             end_activation(value);    /* 0=error during activation, 1=ok */
  238.             break;
  239.  
  240.         case I_END_RENDEZVOUS:
  241.             end_rendezvous();
  242.             break;
  243.  
  244.         case I_ENTRY_CALL:
  245.             value = GET_WORD;        /* retrieve parameter from code */
  246.             entry_call((long) ENDLESS,value);
  247.             break;
  248.  
  249.         case I_RAISE_IN_CALLER:
  250.             raise_in_caller();
  251.             break;
  252.  
  253.         case I_SELECTIVE_WAIT:
  254.             value = GET_WORD;        /* number of alternatives */
  255.  
  256.             /* if = 0 then it is a simple accept, entry addr is on stack. */
  257.             /* else: alternative descriptors on to of stack are scanned by */
  258.             /*   the procedure, which leaves the index of the chosen one.  */
  259.  
  260.             selective_wait(value);
  261.             break;
  262.  
  263.         case I_TERMINATE:
  264.             purge_rdv(tp);
  265.             value = GET_BYTE;
  266.             deallocate(BLOCK_FRAME->bf_data_link);
  267.  
  268.             /* bf_tasks_declared always null here */
  269.  
  270.             switch(value) {
  271.  
  272.             case 0: /* task terminates because reaches the end */
  273.                 break;
  274.  
  275.             case 1: /* task terminates because of terminate alternative */
  276.                 break;
  277.  
  278.             case 2:
  279.                 value = 0;
  280. #ifdef GWUMON
  281.                 {
  282.                 char msg[240];
  283.                 sprintf(msg,"task %d terminated due to unhandled exception: %s\n"
  284.                       ,tp,exception_slots[exr]);
  285.                 CWK_Exception_Raised( tp, msg );
  286.                 }
  287. #else
  288.                 if (exception_trace)
  289.                     printf("task %d terminated due to unhandled exception: %s\n"
  290.                       ,tp,exception_slots[exr]);
  291. #endif
  292.                 break;
  293.  
  294.             case 3:
  295.                 printf("unhandled exception in library unit %s\n",
  296.                   exception_slots[exr]);
  297.                 return RC_ERRORS;
  298.  
  299.             case 4:
  300.                 printf("main task terminated due to unhandled exception %s\n",
  301.                   exception_slots[exr]);
  302.                 printf("propagated from %s",code_slots[raise_cs]);
  303.                 if (raise_lin) printf(" at line %d",raise_lin);
  304.                 printf(" (%s)\n",raise_reason);
  305.                 return RC_ERRORS;
  306.  
  307.             case 5: /* normal end of main */
  308.                 return RC_SUCCESS;
  309.  
  310.             case 6: /* dead-lock */
  311.                 printf("dead-lock: system inactive\n");
  312.                 return RC_ERRORS;
  313.             }
  314.             complete_task();
  315.             break;
  316.  
  317.         case I_TIMED_ENTRY_CALL:
  318.             POPL(lvalue);
  319.             /* retrieve length of parameter table from code */
  320.             entry_call((lvalue >= 0) ? lvalue : (long) 0, GET_WORD);
  321.             break;
  322.  
  323.         case I_WAIT:     /* delay */
  324.             POPL(lvalue);
  325.             delay_stmt(lvalue);
  326.             break;
  327.  
  328.             /* Instructions for Memory Allocation */
  329.  
  330.         case I_CREATE_B:
  331.         case I_CREATE_W:
  332.             create(1, &bse, &off, &ptr);
  333.             PUSH_ADDR(bse, off);
  334.             break;
  335.  
  336.         case I_CREATE_L:
  337.             create(WORDS_LONG, &bse, &off, &ptr);
  338.             PUSH_ADDR(bse, off);
  339.             break;
  340.  
  341.         case I_CREATE_A:
  342.             create(2, &bse, &off, &ptr);
  343.             PUSH_ADDR(bse, off);
  344.             break;
  345.  
  346.         case I_CREATE_STRUC:
  347.             create_structure();
  348.             break;
  349.  
  350.         case I_CREATE_COPY_STRUC:
  351.             create_copy_struc();
  352.             break;
  353.  
  354.         case I_CREATE_COPY_B:
  355.         case I_CREATE_COPY_W:
  356.             create(1, &bse, &off, &ptr);
  357.             POP(value);
  358.             PUSH_ADDR(bse, off);
  359.             *ptr = value;
  360.             break;
  361.  
  362.         case I_CREATE_COPY_L:
  363.             create(WORDS_LONG, &bse, &off, &ptr);
  364.             POPL(lvalue);
  365.             PUSH_ADDR(bse, off);
  366.             *LONG(ptr) = lvalue;
  367.             break;
  368.  
  369.         case I_CREATE_COPY_A:
  370.             create(2, &bse, &off, &ptr);
  371.             POP_ADDR(bas1, off1);
  372.             PUSH_ADDR(bse, off);
  373.             *ptr++ = bas1;
  374.             *ptr = off1;
  375.             break;
  376.  
  377.         case I_DECLARE_B:
  378.         case I_DECLARE_W:
  379.             create(1, &bse, &off, &ptr);
  380.             sp = sfp + GET_WORD;
  381.             cur_stack[sp] = bse;
  382.             cur_stack[sp + 1] = off;
  383.             break;
  384.  
  385.         case I_DECLARE_D:
  386.             create(4, &bse, &off, &ptr);
  387.             sp = sfp + GET_WORD;
  388.             cur_stack[sp] = bse;
  389.             cur_stack[sp + 1] = off;
  390.             break;
  391.  
  392.         case I_DECLARE_L:
  393.             create(WORDS_LONG, &bse, &off, &ptr);
  394.             sp = sfp + GET_WORD;
  395.             cur_stack[sp] = bse;
  396.             cur_stack[sp + 1] = off;
  397.             break;
  398.  
  399.         case I_DECLARE_A:
  400.             create(2, &bse, &off, &ptr);
  401.             sp = sfp + GET_WORD;
  402.             cur_stack[sp] = bse;
  403.             cur_stack[sp + 1] = off;
  404.             break;
  405.  
  406.         case I_ALLOCATE:
  407.             allocate_new();
  408.             break;
  409.  
  410.         case I_ALLOCATE_COPY_G:
  411.             GET_GAD(bse, off);            /* addr. of the type template */
  412.             allocate_copy(bse, off);
  413.             break;
  414.  
  415.         case I_ALLOCATE_COPY_L:
  416.             GET_LAD(bse, off);            /* addr. of the type template */
  417.             allocate_copy(bse, off);
  418.             break;
  419.  
  420.         case I_UPDATE:
  421.             sp = sfp + GET_WORD;
  422.             cur_stack[sp] = TOSM(1);    /* base */
  423.             cur_stack[sp + 1] = TOS;    /* offset */
  424.             break;
  425.  
  426.         case I_UPDATE_AND_DISCARD:
  427.             sp = sfp + GET_WORD;
  428.             POP_ADDR(bse, off);
  429.             cur_stack[sp] = bse;
  430.             cur_stack[sp + 1] = off;
  431.             break;
  432.  
  433.         case I_UNCREATE:
  434.             POP_ADDR(bse, off);
  435.             ptr = ADDR(bse, off) - WORDS_PTR - 1;
  436.             *ptr = - *ptr;
  437.             break;
  438.             /* should withdraw the variable from bf_data_link TBSL */
  439.  
  440.             /* Data Transfer Instructions */
  441.  
  442.         case I_COMPARE_B:
  443.         case I_COMPARE_W:
  444.             POP(val1);
  445.             POP(val2);
  446.             value = (val1 == val2) + 2 *((val1 < val2) ? 1:0);
  447.             /* 0 1 2 for < = > */
  448.             PUSH(value);
  449.             break;
  450.  
  451.         case I_COMPARE_L:
  452.             POPL(lval1);
  453.             POPL(lval2);
  454.             value = (lval1 == lval2) + 2 *((lval1 < lval2) ? 1:0);
  455.             /* 0 1 2 for < = > */
  456.             PUSH(value);
  457.             break;
  458.  
  459.         case I_COMPARE_A:
  460.             POP_ADDR(bas1, off1);
  461.             POP_ADDR(bas2, off2);
  462.             value = (off1 == off2 && bas1 == bas2);
  463.             PUSH(value);
  464.             break;
  465.  
  466.         case I_COMPARE_ARRAYS:
  467.             compare_arrays();
  468.             break;
  469.  
  470.         case I_COMPARE_STRUC:
  471.             compare_struc();
  472.             break;
  473.  
  474.         case I_DEREF_B:
  475.         case I_DEREF_W:
  476.             POP_ADDR(bse, off);
  477.             if (bse == 255)
  478.                 raise(CONSTRAINT_ERROR, "Null access value");
  479.             else {
  480.                 value = *ADDR(bse, off);
  481.                 PUSH(value);
  482.             }
  483.             break;
  484.  
  485.         case I_DEREF_L:
  486.             POP_ADDR(bse, off);
  487.             if (bse == 255)
  488.                 raise(CONSTRAINT_ERROR, "Null access value");
  489.             else {
  490.                 lvalue = *ADDRL(bse, off);
  491.                 PUSHL(lvalue);
  492.             }
  493.             break;
  494.  
  495.         case I_DEREF_A:
  496.             POP_ADDR(bse, off);
  497.             if (bse == 255)
  498.                 raise(CONSTRAINT_ERROR, "Null access value");
  499.             else {
  500.                 value = *ADDR(bse, off);
  501.                 PUSH(value);
  502.                 value = *ADDR(bse, off + 1);
  503.                 PUSH(value);
  504.             }
  505.             break;
  506.  
  507.         case I_DEREF_D:
  508.             POP_ADDR(bse, off);
  509.             if (bse == 255)
  510.                 raise(CONSTRAINT_ERROR, "Null access value");
  511.             else {
  512.                 value = *ADDR(bse, off);
  513.                 PUSH(value);
  514.                 value = *ADDR(bse, off + 1);
  515.                 PUSH(value);
  516.                 value = *ADDR(bse, off + 2);
  517.                 PUSH(value);
  518.                 value = *ADDR(bse, off + 3);
  519.                 PUSH(value);
  520.             }
  521.             break;
  522.  
  523.         case I_DISCARD_ADDR:
  524.             value = GET_WORD;
  525.             cur_stackptr -= (2 * value);
  526.             break;
  527.  
  528.         case I_DUPLICATE_B:
  529.         case I_DUPLICATE_W:
  530.             value = TOS;
  531.             PUSH(value);
  532.             break;
  533.  
  534.         case I_DUPLICATE_L:
  535.             lvalue = TOSL;
  536.             PUSHL(lvalue);
  537.             break;
  538.  
  539.         case I_DUPLICATE_A:
  540.             POP_ADDR(bse, off);
  541.             PUSH_ADDR(bse, off);
  542.             PUSH_ADDR(bse, off);
  543.             break;
  544.  
  545.         case I_DUPLICATE_D:
  546.             value = TOSM(3);
  547.             PUSH(value);
  548.             value = TOSM(3);
  549.             PUSH(value);
  550.             value = TOSM(3);
  551.             PUSH(value);
  552.             value = TOSM(3);
  553.             PUSH(value);
  554.             break;
  555.  
  556.         case I_INDIRECT_MOVE_B:
  557.         case I_INDIRECT_MOVE_W:
  558.             POP_ADDR(bas1, off1);
  559.             POP_ADDR(bas2, off2);
  560.             if (bas1 == 255 || bas2 == 255)
  561.                 raise(CONSTRAINT_ERROR, "Null access value");
  562.             else
  563.                 *ADDR(bas2, off2) = *ADDR(bas1, off1);
  564.             break;
  565.  
  566.         case I_INDIRECT_MOVE_L:
  567.             POP_ADDR(bas1, off1);
  568.             POP_ADDR(bas2, off2);
  569.             if (bas1 == 255 || bas2 == 255)
  570.                 raise(CONSTRAINT_ERROR, "Null access value");
  571.             else
  572.                 *ADDRL(bas2, off2) = *ADDRL(bas1, off1);
  573.             break;
  574.  
  575.         case I_INDIRECT_MOVE_A:
  576.             POP_ADDR(bas1, off1);
  577.             POP_ADDR(bas2, off2);
  578.             if (bas1 == 255 || bas2 == 255)
  579.                 raise(CONSTRAINT_ERROR, "Null access value");
  580.             else {
  581.                 *ADDR(bas2, off2) = *ADDR(bas1, off1);
  582.                 *ADDR(bas2, off2 + 1) = *ADDR(bas1, off1 + 1);
  583.             }
  584.             break;
  585.  
  586.         case I_INDIRECT_POP_B_G:
  587.         case I_INDIRECT_POP_W_G:
  588.             GET_GAD(bse, off);
  589.             POP_ADDR(bas1, off1);
  590.             if (bas1 == 255)
  591.                 raise(CONSTRAINT_ERROR, "Null access value");
  592.             else
  593.                 *ADDR(bse, off) = *ADDR(bas1, off1);
  594.             break;
  595.  
  596.         case I_INDIRECT_POP_L_G:
  597.             GET_GAD(bse, off);
  598.             POP_ADDR(bas1, off1);
  599.             if (bas1 == 255)
  600.                 raise(CONSTRAINT_ERROR, "Null access value");
  601.             else
  602.                 *ADDRL(bse, off) = *ADDRL(bas1, off1);
  603.             break;
  604.  
  605.         case I_INDIRECT_POP_A_G:
  606.             GET_GAD(bse, off);
  607.             POP_ADDR(bas1, off1);
  608.             if (bas1 == 255)
  609.                 raise(CONSTRAINT_ERROR, "Null access value");
  610.             else {
  611.                 *ADDR(bse, off) = *ADDR(bas1, off1);
  612.                 *ADDR(bse, off + 1) = *ADDR(bas1, off1 + 1);
  613.             }
  614.             break;
  615.  
  616.         case I_INDIRECT_POP_B_L:
  617.         case I_INDIRECT_POP_W_L:
  618.             GET_LAD(bse, off);
  619.             POP_ADDR(bas1, off1);
  620.             if (bas1 == 255)
  621.                 raise(CONSTRAINT_ERROR, "Null access value");
  622.             else
  623.                 *ADDR(bse, off) = *ADDR(bas1, off1);
  624.             break;
  625.  
  626.         case I_INDIRECT_POP_L_L:
  627.             GET_LAD(bse, off);
  628.             POP_ADDR(bas1, off1);
  629.             if (bas1 == 255)
  630.                 raise(CONSTRAINT_ERROR, "Null access value");
  631.             else
  632.                 *ADDRL(bse, off) = *ADDRL(bas1, off1);
  633.             break;
  634.  
  635.         case I_INDIRECT_POP_A_L:
  636.             GET_LAD(bse, off);
  637.             POP_ADDR(bas1, off1);
  638.             if (bas1 == 255)
  639.                 raise(CONSTRAINT_ERROR, "Null access value");
  640.             else {
  641.                 *ADDR(bse, off) = *ADDR(bas1, off1);
  642.                 *ADDR(bse, off + 1) = *ADDR(bas1, off1 + 1);
  643.             }
  644.             break;
  645.  
  646.         case I_MOVE_B:
  647.         case I_MOVE_W:
  648.             POP(value);
  649.             POP_ADDR(bse, off);
  650.             if (bse == 255)
  651.                 raise(CONSTRAINT_ERROR, "Null access value");
  652.             else 
  653.                 *ADDR(bse, off) = value;
  654.             break;
  655.  
  656.         case I_MOVE_L:
  657.             POPL(lvalue);
  658.             POP_ADDR(bse, off);
  659.             if (bse == 255)
  660.                 raise(CONSTRAINT_ERROR, "Null access value");
  661.             else 
  662.                 *ADDRL(bse, off) = lvalue;
  663.             break;
  664.  
  665.         case I_MOVE_A:
  666.             POP_ADDR(bas1, off1);
  667.             POP_ADDR(bse, off);
  668.             ptr = ADDR(bse, off);
  669.             *ptr++ = bas1;
  670.             *ptr = off1;
  671.             break;
  672.  
  673.         case I_POP_B_G:
  674.         case I_POP_W_G:
  675.             GET_GAD(bse, off);
  676.             POP(value);
  677.             *ADDR(bse, off) = value;
  678.             break;
  679.  
  680.         case I_POP_L_G:
  681.             GET_GAD(bse, off);
  682.             POPL(lvalue);
  683.             *ADDRL(bse, off) = lvalue;
  684.             break;
  685.  
  686.         case I_POP_D_G:
  687.             /* This has to be set later  TBSL:
  688.              * for the moment, we do not take care of the poped value. We
  689.              * beleive this is only being used for the evaluation of object size
  690.              */
  691.             GET_GAD(bse, off);
  692.             for (i=1; i <= 4 ; i++)
  693.                 POP (value);
  694.             break;
  695.  
  696.         case I_POP_D_L:
  697.             GET_LAD(bse, off);
  698.             for (i=1; i <= 4; i++)
  699.                 POP (value);
  700.             break;
  701.  
  702.         case I_POP_A_G:
  703.             GET_GAD(bse, off);
  704.             POP_ADDR(bas1, off1);
  705.             *ADDR(bse, off) = bas1;
  706.             *ADDR(bse, off + 1) = off1;
  707.             break;
  708.  
  709.         case I_POP_B_L:
  710.         case I_POP_W_L:
  711.             GET_LAD(bse, off);
  712.             POP(value);
  713.             *ADDR(bse, off) = value;
  714.             break;
  715.  
  716.         case I_POP_L_L:
  717.             GET_LAD(bse, off);
  718.             POPL(lvalue);
  719.             *ADDRL(bse, off) = lvalue;
  720.             break;
  721.  
  722.         case I_POP_A_L:
  723.             GET_LAD(bse, off);
  724.             POP_ADDR(bas1, off1);
  725.             *ADDR(bse, off) = bas1;
  726.             *ADDR(bse, off + 1) = off1;
  727.             break;
  728.  
  729.         case I_PUSH_B_G:
  730.         case I_PUSH_W_G:
  731.             GET_GAD(bse, off);
  732.             value = *ADDR(bse, off);
  733.             PUSH(value);
  734.             break;
  735.  
  736.         case I_PUSH_L_G:
  737.             GET_GAD(bse, off);
  738.             lvalue = *ADDRL(bse, off);
  739.             PUSHL(lvalue);
  740.             break;
  741.  
  742.         case I_PUSH_A_G:
  743.             GET_GAD(bse, off);
  744.             ptr = ADDR(bse, off);
  745.             bas1 = *ptr++;
  746.             off1 = *ptr;
  747.             PUSH_ADDR(bas1, off1);
  748.             break;
  749.  
  750.         case I_PUSH_B_L:
  751.         case I_PUSH_W_L:
  752.             GET_LAD(bse, off);
  753.             value = *ADDR(bse, off);
  754.             PUSH(value);
  755.             break;
  756.  
  757.         case I_PUSH_L_L:
  758.             GET_LAD(bse, off);
  759.             lvalue = *ADDRL(bse, off);
  760.             PUSHL(lvalue);
  761.             break;
  762.  
  763.         case I_PUSH_A_L:
  764.             GET_LAD(bse, off);
  765.             ptr = ADDR(bse, off);
  766.             bas1 = *ptr++;
  767.             off1 = *ptr;
  768.             PUSH_ADDR(bas1, off1);
  769.             break;
  770.  
  771.         case I_PUSH_EFFECTIVE_ADDRESS_G:
  772.         case I_PUSH_IMMEDIATE_A:
  773.             GET_GAD(bse, off);
  774.             PUSH_ADDR(bse, off);
  775.             break;
  776.  
  777.         case I_PUSH_EFFECTIVE_ADDRESS_L:
  778.             GET_LAD(bse, off);
  779.             PUSH_ADDR(bse, off);
  780.             break;
  781.  
  782.         case I_PUSH_IMMEDIATE_B:
  783.             PUSH(GET_WORD);
  784.             break;
  785.  
  786.         case I_PUSH_IMMEDIATE_W:
  787.             PUSH(GET_WORD);
  788.             break;
  789.  
  790.         case I_PUSH_IMMEDIATE_L:
  791. #ifdef ALIGN_WORD
  792.             lvalue = get_long(LONG(cur_code + ip));
  793. #else
  794.             lvalue = *LONG(cur_code + ip);
  795. #endif
  796.             PUSHL(lvalue);
  797.             ip += sizeof(long);
  798.             break;
  799.  
  800.             /* Floating Point Instructions */
  801.  
  802.         case I_FLOAT_ADD_L:
  803.             POPF(rval2);
  804.             POPF(rval1);
  805.             rvalue = rval1 + rval2;
  806.             if (ABS(rvalue) > ADA_MAX_REAL)
  807.                 raise(NUMERIC_ERROR, "Floating point addition overflow");
  808.             PUSHF(rvalue);
  809.             break;
  810.  
  811.         case I_FLOAT_SUB_L:
  812.             POPF(rval2);
  813.             POPF(rval1);
  814.             rvalue = rval1 - rval2;
  815.             if (ABS(rvalue) > ADA_MAX_REAL)
  816.                 raise(NUMERIC_ERROR, "Floating point subtraction overflow");
  817.             PUSHF(rvalue);
  818.             break;
  819.  
  820.         case I_FLOAT_MUL_L:
  821.             POPF(rval2);
  822.             POPF(rval1);
  823.             rvalue = rval1 * rval2;
  824.             if (ABS(rvalue) > ADA_MAX_REAL)
  825.                 raise(NUMERIC_ERROR, "Floating point multiplication overflow");
  826.             PUSHF(rvalue);
  827.             break;
  828.  
  829.         case I_FLOAT_DIV_L:
  830.             POPF(rval2);
  831.             POPF(rval1);
  832.             if (rval2 == 0.0)
  833.                 raise(NUMERIC_ERROR, "Floating point division by zero");
  834.             else {
  835.                 rvalue = rval1 / rval2;
  836.                 if (ABS(rvalue) > ADA_MAX_REAL)
  837.                     raise(NUMERIC_ERROR, "Floating point division overflow");
  838.             }
  839.             PUSHF(rvalue);
  840.             break;
  841.  
  842.         case I_FLOAT_COMPARE_L:
  843.             POPF(rval1);
  844.             POPF(rval2);
  845.             value = (rval1 == rval2) + 2 *(rval1 < rval2);
  846.             /* 0 1 2 for < = > */
  847.             PUSH(value);
  848.             break;
  849.  
  850.         case I_FLOAT_POW_L:
  851.             POP(val2);
  852.             POPF(rval1);
  853.             if (val2 == 0)
  854.                 rvalue = 1.0;                /* x ** 0 = 0.0 */
  855.             else if (rval1 == 0.0) {
  856.                 if (val2 < 0)                /* 0 ** -x = error */
  857.                     raise(NUMERIC_ERROR, "Negative power of zero");
  858.                 else
  859.                     rvalue = 0.0;/* 0 ** +x = 0.0 */
  860.             }
  861.             else {
  862.                 rvalue = rval1;
  863.                 for (i = 1; i < ABS(val2); i++) {
  864.                     rvalue = rvalue * rval1;
  865.                     if (ABS(rvalue) > ADA_MAX_REAL) {
  866.                         if (val2 > 0) {
  867.                             /* the exception has to be raised only if the
  868.                              * exponent is positive. If it is negative, the
  869.                              * result will converge towards 0
  870.                              */
  871.                             raise(NUMERIC_ERROR, "Exponentiation");
  872.                             break;
  873.                         }
  874.                         else { 
  875.                             rvalue = 0.0; 
  876.                             val2 = 1;
  877.                             break ; 
  878.                         }
  879.                     }
  880.                 }
  881.                 if (val2 < 0)
  882.                     rvalue = 1.0 / rvalue;
  883.             }
  884.             PUSHF(rvalue);
  885.             break;
  886.  
  887.         case I_FLOAT_NEG_L:
  888.             POPF(rval1);
  889.             rvalue = -rval1;
  890.             PUSHF(rvalue);
  891.             break;
  892.  
  893.         case I_FLOAT_ABS_L:
  894.             POPF(rval1);
  895.             rvalue = ABS(rval1);
  896.             PUSHF(rvalue);
  897.             break;
  898.  
  899.             /* Logical and Arithmetic Instructions */
  900.  
  901.         case I_ADD_B:
  902.             POP(val2);
  903.             POP(val1);
  904.             value = val1 + val2;
  905.             if (value < -128 || value > 127)
  906.                 raise(NUMERIC_ERROR, "Overflow");
  907.             else
  908.                 PUSH(value);
  909.             break;
  910.  
  911.         case I_ADD_W:
  912.             POP(val2);
  913.             POP(val1);
  914.             value = word_add(val1, val2, &overflow);
  915.             if (overflow)
  916.                 raise(NUMERIC_ERROR, "Overflow");
  917.             else
  918.                 PUSH(value);
  919.             break;
  920.  
  921.         case I_ADD_L:
  922.             POPL(lval2);
  923.             POPL(lval1);
  924.             lvalue = long_add(lval1, lval2, &overflow);
  925.             if (overflow)
  926.                 raise(NUMERIC_ERROR, "Overflow");
  927.             else
  928.                 PUSHL(lvalue);
  929.             break;
  930.  
  931.         case I_ADD_IMMEDIATE_B:
  932.             POP(val1);
  933.             val2 = GET_WORD;
  934.             value = val1 + val2;
  935.             if (value < -128 || value > 127)
  936.                 raise(NUMERIC_ERROR, "Overflow");
  937.             else
  938.                 PUSH(value);
  939.             break;
  940.  
  941.         case I_ADD_IMMEDIATE_W:
  942.             POP(val1);
  943.             val2 = GET_WORD;
  944.             value = word_add(val1, val2, &overflow);
  945.             if (overflow)
  946.                 raise(NUMERIC_ERROR, "Overflow");
  947.             PUSH(value);
  948.             break;
  949.  
  950.         case I_ADD_IMMEDIATE_L:
  951.             POPL(lval1);
  952. #ifdef ALIGN_WORD
  953.             lval2 = get_long(LONG(cur_code + ip));
  954. #else
  955.             lval2 = *(LONG(cur_code + ip));
  956. #endif
  957.             ip += WORDS_LONG;
  958.             lvalue = long_add(lval1, lval2, &overflow);
  959.             if (overflow)
  960.                 raise(NUMERIC_ERROR, "Overflow");
  961.             PUSHL(lvalue);
  962.             break;
  963.  
  964.         case I_DIV_B:
  965.             POP(val2);
  966.             POP(val1);
  967.             if (val2 == 0)
  968.                 raise(NUMERIC_ERROR, "Division by zero");
  969.             else if (val1 == -128 && val2 == -1)
  970.                 raise(NUMERIC_ERROR, "Overflow");
  971.             else {
  972.                 value = val1 / val2;
  973.                 PUSH(value);
  974.             }
  975.             break;
  976.  
  977.         case I_DIV_W:
  978.             POP(val2);
  979.             POP(val1);
  980.             if (val2 == 0)
  981.                 raise(NUMERIC_ERROR, "Division by zero");
  982.             else if (val1 == MIN_INTEGER && val2 == -1)
  983.                 raise(NUMERIC_ERROR, "Overflow");
  984.             else {
  985.                 value = val1 / val2;
  986.                 PUSH(value);
  987.             }
  988.             break;
  989.  
  990.         case I_DIV_L:
  991.             POPL(lval2);
  992.             POPL(lval1);
  993.             if (lval2 == 0)
  994.                 raise(NUMERIC_ERROR, "Division by zero");
  995.             else if (lval1 == MIN_LONG && lval2 == -1)
  996.                 raise(NUMERIC_ERROR, "Overflow");
  997.             else {
  998.                 lvalue = lval1 / lval2;
  999.                 PUSHL(lvalue);
  1000.             }
  1001.             break;
  1002.  
  1003.         case I_REM_B:
  1004.         case I_REM_W:
  1005.             /*
  1006.              * Remainder Operation
  1007.              * -------------------
  1008.              * 
  1009.              * The modification has been done in order to prevent complex
  1010.              * calculation. The remonder operator of Ada is equivallent to "%"
  1011.              * of C. The modification is straightfoward.
  1012.              * 
  1013.              * NB : The previous program was not satisfying. The first operation
  1014.              * was to transform the second parameter into a positive one. The
  1015.              * assignment "val2 = -val2" can be incorrect if the value is the
  1016.              * first integer (-2 ** 31) since 2**31 is not an integer.
  1017.              */
  1018.  
  1019.             POP(val2);
  1020.             POP(val1);
  1021.             if (val2 == 0)
  1022.                 raise(NUMERIC_ERROR, "Division by zero");
  1023.             else {
  1024.                 value = val1 % val2;
  1025.                 PUSH(value);
  1026.             }
  1027.             break;
  1028.  
  1029.         case I_REM_L:
  1030.             POPL(lval2);
  1031.             POPL(lval1);
  1032.             if (lval2 == 0)
  1033.                 raise(NUMERIC_ERROR, "Division by zero");
  1034.             else {
  1035.                 lvalue = lval1 % lval2;
  1036.                 PUSHL(lvalue);
  1037.             }
  1038.             break;
  1039.  
  1040.         case I_MOD_B:
  1041.         case I_MOD_W:
  1042.  
  1043.             /* Modulo Operation
  1044.              * ----------------
  1045.              * 
  1046.              * The idea of the modification is to reduce the complexity of the
  1047.              * calculation. The, modulo can be calculated quite easily if the
  1048.              * first parameter is positive. Therefore if the first parameter is
  1049.              * negative then we calculate the first positive number according
  1050.              * to the following equality:
  1051.               * a mod b = (a + n*b) mod b
  1052.              */
  1053.  
  1054.             POP(val2);
  1055.             POP(val1);
  1056.             if (val2 == 0)
  1057.                 raise(NUMERIC_ERROR, "Division by zero");
  1058.             else {
  1059.                 /* the idea is to transform val1 in a positive value.
  1060.                  * a mod b = (a + k*b) mod b
  1061.                  */
  1062.                 if ( (val1 <= 0) && ( val2 > 0)) {
  1063.                     /* val1 = (val1 + (1 - val1/val2)* val2  */
  1064.                     val1 = val1 - ((val1/val2) * val2) + val2; 
  1065.                 }
  1066.                 if ( (val1 <= 0) && ( val2 < 0)) {
  1067.                     /* val1 = (val1 + (-1 - val1/val2)* val2  */
  1068.                     val1 = (val1 - val2) - (val1/val2)*val2; 
  1069.                 }
  1070.                 if (val2 > 0)
  1071.                     value = val1 % val2;
  1072.                 else
  1073.                     value = (val2 + (val1 % val2)) % val2;
  1074.                 PUSH(value);
  1075.             }
  1076.             break;
  1077.  
  1078.         case I_MOD_L:
  1079.             POPL(lval2);
  1080.             POPL(lval1);
  1081.             if (lval2 == 0)
  1082.                 raise(NUMERIC_ERROR, "Division by zero");
  1083.             else {
  1084.                 /* the idea is to transform lval1 in a positive value.
  1085.                  * a mod b = (a + k*b) mod b
  1086.                  */
  1087.                 if ( (lval1 <= 0) && ( lval2 > 0)) {
  1088.                     /* lval1 = (lval1 + (1 - lval1/lval2)* lval2  */
  1089.                     lval1 = lval1 - ((lval1/lval2) * lval2) + lval2; 
  1090.                 }
  1091.                 if ( (lval1 <= 0) && ( lval2 < 0)) {
  1092.                     /* lval1 = (lval1 + (-1 - lval1/lval2)* lval2  */
  1093.                     lval1 = (lval1 - lval2) - (lval1/lval2)*lval2; 
  1094.                 }
  1095.                 if (lval2 > 0)
  1096.                     lvalue = lval1 % lval2;
  1097.                 else
  1098.                     lvalue = (lval2 + (lval1 % lval2)) % lval2;
  1099.                 PUSHL(lvalue);
  1100.             }
  1101.             break;
  1102.  
  1103.         case I_MUL_B:
  1104.             POP(val2);
  1105.             POP(val1);
  1106.             value = val1 * val2;
  1107.             if (value < -128 || value > 127)
  1108.                 raise(NUMERIC_ERROR, "Overflow");
  1109.             else
  1110.                 PUSH(value);
  1111.             break;
  1112.  
  1113.         case I_MUL_W:
  1114.             POP(val2);
  1115.             POP(val1);
  1116.             value = word_mul(val1, val2, &overflow);
  1117.             if (overflow)
  1118.                 raise(NUMERIC_ERROR, "Overflow");
  1119.             PUSH(value);
  1120.             break;
  1121.  
  1122.         case I_MUL_L:
  1123.             POPL(lval2);
  1124.             POPL(lval1);
  1125.             lvalue = long_mul(lval1, lval2, &overflow);
  1126.             if (overflow)
  1127.                 raise(NUMERIC_ERROR, "Overflow");
  1128.             PUSHL(lvalue);
  1129.             break;
  1130.  
  1131.         case I_POW_B:
  1132.             POP(val2);
  1133.             POP(val1);
  1134.             if (val2 < 0)
  1135.                 raise(NUMERIC_ERROR, "Overflow");
  1136.             else if (val2 == 0)
  1137.                 value = 1;
  1138.             else {
  1139.                 value = val1;
  1140.                 for (i = 1; i < val2; i++) {
  1141.                     value = value * val1;
  1142.                     if (value > 127)
  1143.                         raise(NUMERIC_ERROR, "Overflow");
  1144.                 }
  1145.             }
  1146.             PUSH(value);
  1147.             break;
  1148.  
  1149.         case I_POW_W:
  1150.             POP(val2);
  1151.             POP(val1);
  1152.             if (val2 < 0)
  1153.                 raise(NUMERIC_ERROR, "Overflow");
  1154.             else if (val2 == 0)
  1155.                 value = 1;
  1156.             else
  1157.                 value = val1;
  1158.             for (i = 1; i < val2; i++) {
  1159.                 value = word_mul(value, val1, &overflow);
  1160.                 if (overflow)
  1161.                     raise(NUMERIC_ERROR, "Overflow");
  1162.             }
  1163.             PUSH(value);
  1164.             break;
  1165.  
  1166.         case I_POW_L:
  1167.             POPL(lval2);
  1168.             POPL(lval1);
  1169.             if (lval2 < 0)
  1170.                 raise(NUMERIC_ERROR, "Overflow");
  1171.             else if (lval2 == 0)
  1172.                 lvalue = 1;
  1173.             else {
  1174.                 lvalue = lval1;
  1175.                 for (i = 1; i < lval2; i++) {
  1176.                     lvalue = long_mul(lvalue, lval1, &overflow);
  1177.                     if (overflow)
  1178.                         raise(NUMERIC_ERROR, "Overflow");
  1179.                 }
  1180.             }
  1181.             PUSHL(lvalue);
  1182.             break;
  1183.  
  1184.         case I_FIX_MUL:
  1185.             POP_ADDR(bas1, off1);/* type and value of op2 */
  1186.             ptr2 = ADDR(bas1, off1);
  1187.             POPL(fval2);
  1188.  
  1189.             POP_ADDR(bas1, off1);/* type and value of op1 */
  1190.             ptr1 = ADDR(bas1, off1);
  1191.             POPL(fval1);
  1192.  
  1193.             POP_ADDR(bas1, off1);/* result type */
  1194.             ptr = ADDR(bas1, off1);
  1195.  
  1196.             if (fval2 == 0 || fval1 == 0) {
  1197.                 fvalue = 0;
  1198.                 PUSHL(fvalue);
  1199.             }
  1200.             else {
  1201.                 to_type = TYPE(ptr);
  1202.                 if (to_type == TT_FX_RANGE) {
  1203.  
  1204.                     sgn  = SIGN(fval1);
  1205.                     fval1 = ABS(fval1);
  1206.                     sgn *= SIGN(fval2);
  1207.                     fval2 = ABS(fval2);
  1208.                     int_tom(fix_val1,fval1);
  1209.                     int_tom(fix_val2,fval2);
  1210.  
  1211.                     temp_template->small_exp_2 = FX_RANGE(ptr1)->small_exp_2 +
  1212.                       FX_RANGE(ptr2)->small_exp_2;
  1213.                     temp_template->small_exp_5 = FX_RANGE(ptr1)->small_exp_5 +
  1214.                       FX_RANGE(ptr2)->small_exp_5;
  1215.  
  1216.                     int_mul(fix_val1, fix_val2, fix_resu);
  1217.                     fix_convert(fix_resu, temp_template, FX_RANGE(ptr));
  1218.                     fvalue = int_tol(fix_resu);
  1219.                     if (arith_overflow)
  1220.                         raise(NUMERIC_ERROR,
  1221.                           "Fixed point multiplication overflow");
  1222.                     if (fix_out_of_bounds(fvalue, ptr))
  1223.                         raise(CONSTRAINT_ERROR,
  1224.                           "Fixed point value out of bounds");
  1225.                     PUSHL(sgn*fvalue);
  1226.                 }
  1227.                 else
  1228.                     raise(SYSTEM_ERROR, "Conversion to invalid type");
  1229.             }
  1230.             break;
  1231.  
  1232.         case I_FIX_DIV:
  1233.             POP_ADDR(bas1, off1);/* type and value of op2 */
  1234.             ptr2 = ADDR(bas1, off1);
  1235.             POPL(fval2);
  1236.  
  1237.             POP_ADDR(bas1, off1);/* type and value of op1 */
  1238.             ptr1 = ADDR(bas1, off1);
  1239.             POPL(fval1);
  1240.  
  1241.             POP_ADDR(bas1, off1);/* result type */
  1242.             ptr = ADDR(bas1, off1);
  1243.  
  1244.             if (fval2 == 0) {
  1245.                 raise(NUMERIC_ERROR, "Fixed point division by zero");
  1246.                 fvalue = 0;
  1247.                 PUSHL(fvalue);
  1248.             }
  1249.             else {
  1250.                 to_type = TYPE(ptr);
  1251.                 if (to_type == TT_FX_RANGE) {
  1252.  
  1253.                     sgn  = SIGN(fval1);
  1254.                     fval1 = ABS(fval1);
  1255.                     sgn *= SIGN(fval2);
  1256.                     fval2 = ABS(fval2);
  1257.                     int_tom(fix_val1,fval1);
  1258.                     int_tom(fix_val2,fval2);
  1259.  
  1260.                     temp_template->small_exp_2 = FX_RANGE(ptr)->small_exp_2 +
  1261.                       FX_RANGE(ptr2)->small_exp_2;
  1262.                     temp_template->small_exp_5 = FX_RANGE(ptr)->small_exp_5 +
  1263.                       FX_RANGE(ptr2)->small_exp_5;
  1264.  
  1265.                     fix_convert(fix_val1, FX_RANGE(ptr1), temp_template);
  1266.                     int_div(fix_val1, fix_val2, fix_resu);
  1267.                     fvalue = int_tol(fix_resu);
  1268.                     if (arith_overflow)
  1269.                         raise(NUMERIC_ERROR, "Fixed point division overflow");
  1270.                     if (fix_out_of_bounds(fvalue, ptr))
  1271.                         raise(CONSTRAINT_ERROR,
  1272.                           "Fixed point value out of bounds");
  1273.                     PUSHL(sgn*fvalue);
  1274.                 }
  1275.                 else
  1276.                     raise(SYSTEM_ERROR, "Conversion to invalid type");
  1277.             }
  1278.             break;
  1279.  
  1280.         case I_CONVERT_TO_L:
  1281.             GET_LAD(bse, off);
  1282.             convert(bse, off);
  1283.             break;
  1284.  
  1285.         case I_CONVERT_TO_G:
  1286.             GET_GAD(bse, off);
  1287.             convert(bse, off);
  1288.             break;
  1289.  
  1290.         case I_NEG_B:
  1291.             if (TOS == -128)
  1292.                 raise(NUMERIC_ERROR,"Byte overflow");
  1293.             else
  1294.                 TOS = -TOS;
  1295.             break;
  1296.  
  1297.         case I_NEG_W:
  1298.             if (TOS == MIN_INTEGER)
  1299.                 raise(NUMERIC_ERROR,"Overflow");
  1300.             else
  1301.                 TOS = -TOS;
  1302.             break;
  1303.  
  1304.         case I_NEG_L:
  1305.             if (TOS == MIN_LONG)
  1306.                 raise(NUMERIC_ERROR,"Overflow");
  1307.             else
  1308.                 TOSL = -TOSL;
  1309.             break;
  1310.  
  1311.         case I_ABS_B:
  1312.             if (TOS == -128)
  1313.                 raise(NUMERIC_ERROR,"Byte overflow");
  1314.             else
  1315.                 TOS = ABS(TOS);
  1316.             break;
  1317.  
  1318.         case I_ABS_W:
  1319.             if (TOS == MIN_INTEGER)
  1320.                 raise(NUMERIC_ERROR,"Overflow");
  1321.             else
  1322.                 TOS = ABS(TOS);
  1323.             break;
  1324.  
  1325.         case I_ABS_L:
  1326.             if (TOS == MIN_LONG)
  1327.                 raise(NUMERIC_ERROR,"Overflow");
  1328.             else
  1329.                 TOSL = ABS(TOSL);
  1330.             break;
  1331.  
  1332.         case I_NOT:
  1333.             TOS = 1 - TOS;
  1334.             break;
  1335.  
  1336.         case I_AND:
  1337.             POP(val2);
  1338.             POP(val1);
  1339.             value = (val1 & val2);
  1340.             PUSH(value);
  1341.             break;
  1342.  
  1343.         case I_XOR:
  1344.             POP(val2);
  1345.             POP(val1);
  1346.             value = (val1 ^ val2);
  1347.             PUSH(value);
  1348.             break;
  1349.  
  1350.         case I_OR:
  1351.             POP(val2);
  1352.             POP(val1);
  1353.             value = (val1 | val2);
  1354.             PUSH(value);
  1355.             break;
  1356.  
  1357.         case I_IS_EQUAL:
  1358.             TOS = (TOS == 1);
  1359.             break;
  1360.  
  1361.         case I_IS_GREATER:
  1362.             TOS = (TOS == 2);
  1363.             break;
  1364.  
  1365.         case I_IS_GREATER_OR_EQUAL:
  1366.             TOS = (TOS >= 1);
  1367.             break;
  1368.  
  1369.         case I_IS_LESS:
  1370.             TOS = (TOS == 0);
  1371.             break;
  1372.  
  1373.         case I_IS_LESS_OR_EQUAL:
  1374.             TOS = (TOS <= 1);
  1375.             break;
  1376.  
  1377.         case I_MEMBERSHIP:
  1378.             membership();
  1379.             break;
  1380.  
  1381.         case I_QUAL_RANGE_G:
  1382.             GET_GAD(bse, off);
  1383.             ptr1 = ADDR(bse, off);
  1384.             if (TYPE(ptr1) == TT_FX_RANGE) {
  1385.                 if (fix_out_of_bounds(TOSL, ptr1))
  1386.                     raise(CONSTRAINT_ERROR, "Fixed point value out of bounds");
  1387.             }
  1388.             else if (TYPE(ptr1) == TT_FL_RANGE) {
  1389.                 rval1 = FL_RANGE(ptr1)->fllow;
  1390.                 rval2 = FL_RANGE(ptr1)->flhigh;
  1391.                 if (TOSF < rval1 || TOSF > rval2)
  1392.                     raise(CONSTRAINT_ERROR,
  1393.                       "Floating point value out of bounds");
  1394.             }
  1395.             else if ((TYPE(ptr1) == TT_I_RANGE) ||
  1396.                 (TYPE(ptr1) == TT_E_RANGE) ||
  1397.                 (TYPE(ptr1) == TT_ENUM)) {
  1398.                 val_low = I_RANGE(ptr1)->ilow;
  1399.                 val_high = I_RANGE(ptr1)->ihigh;
  1400.                 if (TOS < val_low || TOS > val_high)
  1401.                     raise(CONSTRAINT_ERROR, "Out of bounds");
  1402.             }
  1403. #ifdef LONG_INT
  1404.             else if (TYPE(ptr1) == TT_L_RANGE) {
  1405.                 lvalue = TOSL;
  1406.                 lval_low = L_RANGE(ptr1)->llow;
  1407.                 lval_high = L_RANGE(ptr1)->lhigh;
  1408.                 if (lvalue < lval_low || lvalue > lval_high)
  1409.                     raise (CONSTRAINT_ERROR, "Out of bounds");
  1410.             }
  1411. #endif
  1412.             else    /* error here */
  1413.                 ;
  1414.             break;
  1415.  
  1416.         case I_QUAL_RANGE_L:
  1417.             GET_LAD(bse, off);
  1418.             ptr1 = ADDR(bse, off);
  1419.             if (TYPE(ptr1) == TT_FX_RANGE) {
  1420.                 fval1 = TOSL;
  1421.                 if (fix_out_of_bounds(fval1, ptr1))
  1422.                     raise(CONSTRAINT_ERROR, "Fixed point value out of bounds");
  1423.             }
  1424.             else if (TYPE(ptr1) == TT_FL_RANGE) {
  1425.                 rvalue = TOSF;
  1426.                 rval1 = FL_RANGE(ptr1)->fllow;
  1427.                 rval2 = FL_RANGE(ptr1)->flhigh;
  1428.                 if (rvalue < rval1 || rvalue > rval2)
  1429.                     raise(CONSTRAINT_ERROR,
  1430.                       "Floating point value out of bounds");
  1431.             }
  1432.             else if ((TYPE(ptr1) == TT_I_RANGE) ||
  1433.                 (TYPE(ptr1) == TT_E_RANGE) ||
  1434.                 (TYPE(ptr1) == TT_ENUM)) {
  1435.                 val_low = I_RANGE(ptr1)->ilow;
  1436.                 val_high = I_RANGE(ptr1)->ihigh;
  1437.                 if (TOS < val_low || TOS > val_high)
  1438.                     raise(CONSTRAINT_ERROR, "Out of bounds");
  1439.             }
  1440. #ifdef LONG_INT
  1441.             else if (TYPE(ptr1) == TT_L_RANGE) {
  1442.                 lvalue = TOSL;
  1443.                 lval_low = L_RANGE(ptr1)->llow;
  1444.                 lval_high = L_RANGE(ptr1)->lhigh;
  1445.                 if (lvalue < lval_low || lvalue > lval_high)
  1446.                     raise (CONSTRAINT_ERROR, "Out of bounds");
  1447.             }
  1448. #endif
  1449.             else    /* error here */
  1450.                 ;
  1451.             break;
  1452.  
  1453.         case I_QUAL_DISCR_G:
  1454.             GET_GAD(bse, off);
  1455.             qual_discr(bse, off);
  1456.             break;
  1457.  
  1458.         case I_QUAL_DISCR_L:
  1459.             GET_LAD(bse, off);
  1460.             qual_discr(bse, off);
  1461.             break;
  1462.  
  1463.         case I_QUAL_INDEX_G:
  1464.             GET_GAD(bse, off);
  1465.             ptr = ADDR(bse, off);
  1466.             POP_ADDR(bse, off);
  1467.             PUSH_ADDR(bse, off);
  1468.             ptr1 = ADDR(bse, off);
  1469.             if (!qual_index(ptr, ptr1))
  1470.                 raise(CONSTRAINT_ERROR, "Wrong bounds");
  1471.             break;
  1472.  
  1473.         case I_QUAL_INDEX_L:
  1474.             GET_LAD(bse, off);
  1475.             ptr = ADDR(bse, off);
  1476.             POP_ADDR(bse, off);
  1477.             PUSH_ADDR(bse, off);
  1478.             ptr1 = ADDR(bse, off);
  1479.             if (!qual_index(ptr, ptr1))
  1480.                 raise(CONSTRAINT_ERROR, "Wrong bounds");
  1481.             break;
  1482.  
  1483.         case I_QUAL_SUB_G:
  1484.             GET_GAD(bse, off);
  1485.             ptr = ADDR(bse, off);
  1486.             POP_ADDR(bse, off);
  1487.             PUSH_ADDR(bse, off);
  1488.             ptr1 = ADDR(bse, off);
  1489.             if (!qual_sub(ptr, ptr1))
  1490.                 raise(CONSTRAINT_ERROR, "Wrong bounds");
  1491.             break;
  1492.  
  1493.         case I_QUAL_SUB_L:
  1494.             GET_LAD(bse, off);
  1495.             ptr = ADDR(bse, off);
  1496.             POP_ADDR(bse, off);
  1497.             PUSH_ADDR(bse, off);
  1498.             ptr1 = ADDR(bse, off);
  1499.             if (!qual_sub(ptr, ptr1))
  1500.                 raise(CONSTRAINT_ERROR, "Wrong bounds");
  1501.             break;
  1502.  
  1503.         case I_SUB_B:
  1504.             POP(val2);
  1505.             POP(val1);
  1506.             value = val1 - val2;
  1507.             if (value < -128 || value > 127)
  1508.                 raise(NUMERIC_ERROR, "Overflow");
  1509.             else
  1510.                 PUSH(value);
  1511.             break;
  1512.  
  1513.         case I_SUB_W:
  1514.             POP(val2);
  1515.             POP(val1);
  1516.             value = word_sub(val1, val2, &overflow);
  1517.             if (overflow)
  1518.                 raise(NUMERIC_ERROR, "Overflow");
  1519.             else
  1520.                 PUSH(value);
  1521.             break;
  1522.  
  1523.         case I_SUB_L:
  1524.             POPL(lval2);
  1525.             POPL(lval1);
  1526.             lvalue = long_sub(lval1, lval2, &overflow);
  1527.             if (overflow)
  1528.                 raise(NUMERIC_ERROR, "Overflow");
  1529.             else
  1530.                 PUSHL(lvalue);
  1531.             break;
  1532.  
  1533.             /* Array Instructions */
  1534.  
  1535.         case I_ARRAY_CATENATE:
  1536.             array_catenate();
  1537.             break;
  1538.  
  1539.         case I_ARRAY_MOVE:
  1540.             array_move();
  1541.             break;
  1542.  
  1543.         case I_ARRAY_SLICE:
  1544.             array_slice();
  1545.             break;
  1546.  
  1547.         case I_ARRAY_AND:
  1548.             POP_ADDR(bas1, off1);/* right type */
  1549.             POP_ADDR(bas2, off2);/* right object */
  1550.             POP_ADDR(bse, off);/* left type */
  1551.             value = SIZE(ADDR(bse, off));
  1552.             if (SIZE(ADDR(bas1, off1)) != value)
  1553.                 raise(CONSTRAINT_ERROR, "Arrays not same size for AND");
  1554.             else {
  1555.                 POP_ADDR(bas1, off1);/* left object */
  1556.                 ptr1 = ADDR(bas1, off1);
  1557.                 ptr2 = ADDR(bas2, off2);
  1558.                 create(value, &bas1, &off1, &ptr);
  1559.                 for (i = 0; i <= value - 1; i++)
  1560.                     *ptr++ = (*ptr1++ & *ptr2++);
  1561.                 PUSH_ADDR(bas1, off1);/* result object */
  1562.                 PUSH_ADDR(bse, off);/* result type */
  1563.             }
  1564.             break;
  1565.  
  1566.         case I_ARRAY_OR:
  1567.             POP_ADDR(bas1, off1);/* right type */
  1568.             POP_ADDR(bas2, off2);/* right object */
  1569.             POP_ADDR(bse, off);/* left type */
  1570.             value = SIZE(ADDR(bse, off));
  1571.             if (SIZE(ADDR(bas1, off1)) != value)
  1572.                 raise(CONSTRAINT_ERROR, "Arrays not same size for OR");
  1573.             else {
  1574.                 POP_ADDR(bas1, off1);/* left object */
  1575.                 ptr1 = ADDR(bas1, off1);
  1576.                 ptr2 = ADDR(bas2, off2);
  1577.                 create(value, &bas1, &off1, &ptr);
  1578.                 for (i = 0; i <= value - 1; i++)
  1579.                     *ptr++ = (*ptr1++ | *ptr2++);
  1580.                 PUSH_ADDR(bas1, off1);/* result object */
  1581.                 PUSH_ADDR(bse, off);/* result type */
  1582.             }
  1583.             break;
  1584.  
  1585.         case I_ARRAY_XOR:
  1586.             POP_ADDR(bas1, off1);/* right type */
  1587.             POP_ADDR(bas2, off2);/* right object */
  1588.             POP_ADDR(bse, off);/* left type */
  1589.             value = SIZE(ADDR(bse, off));
  1590.             if (SIZE(ADDR(bas1, off1)) != value)
  1591.                 raise(CONSTRAINT_ERROR, "Arrays not same size for XOR");
  1592.             else {
  1593.                 POP_ADDR(bas1, off1);/* left object */
  1594.                 ptr1 = ADDR(bas1, off1);
  1595.                 ptr2 = ADDR(bas2, off2);
  1596.                 create(value, &bas1, &off1, &ptr);
  1597.                 for (i = 0; i <= value - 1; i++) {
  1598.                     *ptr++ = (*ptr1++ ^ *ptr2++);
  1599.                 }
  1600.                 PUSH_ADDR(bas1, off1);/* result object */
  1601.                 PUSH_ADDR(bse, off);/* result type */
  1602.             }
  1603.             break;
  1604.  
  1605.         case I_ARRAY_NOT:
  1606.             POP_ADDR(bse, off);/* type */
  1607.             value = SIZE(ADDR(bse, off));
  1608.             POP_ADDR(bas1, off1);/* object */
  1609.             ptr1 = ADDR(bas1, off1);
  1610.             create(value, &bas1, &off1, &ptr);
  1611.             for (i = 0; i <= value - 1; i++)
  1612.                 *ptr++ = (1 - *ptr1++);
  1613.             PUSH_ADDR(bas1, off1);/* result object */
  1614.             PUSH_ADDR(bse, off);/* result type */
  1615.             break;
  1616.  
  1617.             /* Record Instructions */
  1618.  
  1619.         case I_RECORD_MOVE_G:
  1620.             GET_GAD(bse, off);
  1621.             ptr = ADDR(bse, off);
  1622.             POP_ADDR(bas1, off1);/* value */
  1623.             ptr1 = ADDR(bas1, off1);
  1624.             POP_ADDR(bas2, off2);/* object */
  1625.             ptr2 = ADDR(bas2, off2);
  1626.             record_move(ptr2, ptr1, ptr);
  1627.             break;
  1628.  
  1629.         case I_RECORD_MOVE_L:
  1630.             GET_LAD(bse, off);
  1631.             ptr = ADDR(bse, off);
  1632.             POP_ADDR(bas1, off1);/* value */
  1633.             ptr1 = ADDR(bas1, off1);
  1634.             POP_ADDR(bas2, off2);/* object */
  1635.             ptr2 = ADDR(bas2, off2);
  1636.             record_move(ptr2, ptr1, ptr);
  1637.             break;
  1638.  
  1639.             /* Attributes */
  1640.  
  1641.         case I_ATTRIBUTE:
  1642.             attribute = GET_BYTE;
  1643.             /* So that all reads from code segment are done in this
  1644.              * procedure, we retrieve the dim argument used for
  1645.              * some attributes
  1646.              */
  1647.             if (attribute==ATTR_O_FIRST || attribute==ATTR_O_LAST
  1648.               || attribute == ATTR_O_LENGTH || attribute==ATTR_O_RANGE)
  1649.                 value = GET_WORD;
  1650.             else
  1651.                 value = 0;
  1652.             main_attr(attribute,value);
  1653.             break;
  1654.  
  1655.             /* Control Instructions */
  1656.  
  1657.         case I_ENTER_BLOCK:
  1658. #ifdef DEBUG_TASKING
  1659.             if (tasking_trace)
  1660.                 printf("enter block pushing %d for previous\n",bfp);
  1661. #endif
  1662.             PUSH(bfp);    /* save previous BFP */
  1663.             bfp = cur_stackptr;
  1664. #ifdef DEBUG_TASKING
  1665.             if (tasking_trace)
  1666.                 printf("enter block bfp %d\n",bfp);
  1667. #endif
  1668.             PUSHP(0L);    /* data_link */
  1669.             PUSHP(0L);        /* tasks_declared */
  1670.             PUSH(1);    /* num noterm */
  1671.             PUSH(1);    /* num deps */
  1672.             PUSH(NULL_TASK);/* subtasks */
  1673.             PUSH(0);    /* exception vector */
  1674.             break;
  1675.  
  1676.         case I_EXIT_BLOCK:
  1677. #ifdef DEBUG_TASKING
  1678.             if (tasking_trace) {
  1679. #ifdef IBM_PC
  1680.                 printf("exit block bfp %d %p\n",bfp,cur_stack+bfp);
  1681. #else
  1682.                 printf("exit block bfp %d %ld\n",bfp,cur_stack+bfp);
  1683. #endif
  1684.             }
  1685. #endif
  1686.             if (BLOCK_FRAME->bf_num_deps >= 1) {
  1687.                 --ip;    /* to reexecute the 'leave_block' */
  1688.                 complete_block();
  1689.             }
  1690.             else {
  1691.                 deallocate(BLOCK_FRAME->bf_data_link);
  1692.                 sp = BLOCK_FRAME->bf_previous_bfp;
  1693.                 if ((tfptr1 = BLOCK_FRAME->bf_tasks_declared) != 0) {
  1694.                     bfptr = (struct bf *)(&cur_stack[sp]);
  1695.                     tfptr2 = bfptr->bf_tasks_declared;
  1696.                     if (tfptr2 != 0) {
  1697.                         value = pop_task_frame();
  1698.                         *tfptr2 = union_tasks_declared(value, *tfptr2);
  1699.                     }
  1700.                     else    /* put task frame on previous bfp */
  1701.                         bfptr->bf_tasks_declared = tfptr1;
  1702.                 }
  1703.                 cur_stackptr = bfp - 1;
  1704.                 bfp = sp;
  1705. #ifdef DEBUG_TASKING
  1706.                 if (tasking_trace)
  1707.                     printf("exit block setting bfp %d\n",bfp);
  1708. #endif
  1709.             }
  1710.             break;
  1711.  
  1712.         case I_LEAVE_BLOCK:
  1713. #ifdef DEBUG_TASKING
  1714.             if (tasking_trace) {
  1715. #ifdef IBM_PC
  1716.                 printf("leave block bfp %d %p\n",bfp,cur_stack+bfp);
  1717. #else
  1718.                 printf("leave block bfp %d %ld\n",bfp,cur_stack+bfp);
  1719. #endif
  1720.             }
  1721. #endif
  1722.             if (BLOCK_FRAME->bf_num_deps >= 1) {
  1723.                 --ip;    /* to reexecute the 'leave_block' */
  1724.                 complete_block();
  1725.             }
  1726.             else {
  1727.                 deallocate(BLOCK_FRAME->bf_data_link);
  1728.                 sp = BLOCK_FRAME->bf_previous_bfp;
  1729.                 if ((tfptr1 = BLOCK_FRAME->bf_tasks_declared) != 0) {
  1730.                     bfptr = (struct bf *)(&cur_stack[sp]);
  1731.                     tfptr2 = bfptr->bf_tasks_declared;
  1732.                     if (tfptr2 != 0) {
  1733.                         value = pop_task_frame();
  1734.                         *tfptr2 = union_tasks_declared(value, *tfptr2);
  1735.                     }
  1736.                     else    /* put task frame on previous bfp */
  1737.                         bfptr->bf_tasks_declared = tfptr1;
  1738.                 }
  1739.                 if (sp < sfp) {/* return to previous stack_frame */
  1740.                     cur_stackptr = sfp - 1;/* get rid of the relay set */
  1741.                     /* in case an exception is propagated, ip */
  1742.                     /* must point again to the default handler */
  1743. #ifdef ALIGN_WORD
  1744.                     val2 = get_int((int *)(cur_code + code_seglen[cs] 
  1745.                       - sizeof(int) - 1));
  1746. #else
  1747.                     val2 = *(int *)(cur_code+code_seglen[cs] - sizeof(int) - 1);
  1748. #endif
  1749.                     /* length of local variables */
  1750.                     if (ip < 2) {
  1751.                         --cur_stackptr;/* to discard it */
  1752. #ifdef TRACE
  1753.                         if (call_trace)
  1754.                             printf("abandoning %s\n", code_slots[cs]);
  1755. #endif
  1756.                     }
  1757.                     else {
  1758.                         POP(ip);
  1759. #ifdef TRACE
  1760.                         if (call_trace) {
  1761.                             if (code_slots[cs])
  1762.                                 printf("returning from %s (tos %d)\n",
  1763.                                   code_slots[cs],cur_stackptr- 3-val2);
  1764.                             else 
  1765.                                 printf("returning from %s (tos %d)\n", 
  1766.                                   "compiler_generated_procedure",
  1767.                                   cur_stackptr-3-val2);
  1768.                         }
  1769. #endif
  1770. #ifdef GWUMON
  1771.                         if (code_slots[cs])
  1772.                         {
  1773.                             CWK_LEAVE_BLOCK(cs);
  1774.                         }
  1775. #endif
  1776.                     }
  1777.                     POP(lin);
  1778.                     POP(cs);
  1779. #ifdef GWUMON
  1780.                     if (code_slots[cs])
  1781.                     {
  1782.                         CWK_Switch_Block(cs, code_slots[cs],
  1783.                         code_slots_package[cs],
  1784.                         code_slots_file[cs],1 );
  1785.                     }
  1786. #endif
  1787.                     cur_code = code_segments[cs];
  1788.                     POP(sfp);
  1789.                     cur_stackptr -= val2;/* to get rid of it */
  1790.                 }
  1791.                 else
  1792.                     cur_stackptr = bfp - 1;
  1793.                 bfp = sp;
  1794. #ifdef DEBUG_TASKING
  1795.                 if (tasking_trace)
  1796.                     printf("leave block setting bfp %d\n",bfp);
  1797. #endif
  1798.             }
  1799.             break;
  1800.  
  1801.         case I_CALL_L:
  1802.             GET_LAD(bse, off);/* addr of proc. object */
  1803.             ptr = ADDR(bse, off);
  1804.             value = *ptr;
  1805.             if (value < 0)
  1806.                 raise(PROGRAM_ERROR, "Access before elaboration");
  1807.             else {
  1808.                 if (cur_stackptr+SECURITY_LEVEL>new_task_size)
  1809.                     raise(STORAGE_ERROR, "Stack overflow");
  1810.                 else {
  1811.                     old_cs = cs;
  1812.                     cs = value;
  1813. #ifdef GWUMON
  1814.                     if ( code_slots[cs] )
  1815.                         CWK_Switch_Block(cs,
  1816.                             code_slots[cs],
  1817.                             code_slots_package[cs],
  1818.                             code_slots_file[cs],0 );
  1819. #endif
  1820. #ifdef TRACE
  1821.                     if (call_trace) {
  1822.                         if (code_slots[cs])
  1823.                             printf("calling %s (tos %d -> ",
  1824.                               code_slots[cs], cur_stackptr);
  1825.                         else 
  1826.                             printf("calling %s (tos %d -> ",
  1827.                               "compiler_generated_procedure", cur_stackptr);
  1828.                     }
  1829. #endif
  1830.                     cur_code = code_segments[cs];
  1831. #ifdef ALIGN_WORD
  1832.                     val1 = get_int((int *)(cur_code + code_seglen[cs] 
  1833.                       - sizeof(int) - 1));
  1834. #else
  1835.                     val1 = *(int *)(cur_code+code_seglen[cs] - sizeof(int) - 1);
  1836. #endif
  1837.                     /* reserve space for locals */
  1838.                     if (val1 < 0)
  1839.                         raise(SYSTEM_ERROR, "Negative size of locals");
  1840.                     else
  1841.                         cur_stackptr += val1;
  1842.                     PUSH(sfp);
  1843.                     PUSH(old_cs);
  1844.                     PUSH(lin);
  1845.                     PUSH(ip);
  1846.                     sfp = cur_stackptr + 1;
  1847.                     ip = 2;
  1848.                     val2 = *(++ptr) * 2;/* length of relay set */
  1849.                     for (i = 1; i <= val2; i++)            /* copy relay set */
  1850.                         PUSH(*++ptr);
  1851. #ifdef TRACE
  1852.                     if(call_trace)
  1853.                         printf("%d)\n",cur_stackptr);
  1854. #endif
  1855.                 }
  1856.             }
  1857.             break;
  1858.  
  1859.         case I_CALL_G:
  1860.             GET_GAD(bse, off);/* addr of proc. object */
  1861.             ptr = ADDR(bse, off);
  1862.             value = *ptr;
  1863.             if (value < 0)
  1864.                 raise(PROGRAM_ERROR, "Access before elaboration");
  1865.             else {
  1866.                 if (cur_stackptr+SECURITY_LEVEL>new_task_size)
  1867.                     raise(STORAGE_ERROR, "Stack overflow");
  1868.                 else {
  1869.                     old_cs = cs;
  1870.                     cs = value;
  1871. #ifdef GWUMON
  1872.                     if ( code_slots[cs] )
  1873.                         CWK_Switch_Block(cs,
  1874.                             code_slots[cs],
  1875.                             code_slots_package[cs],
  1876.                             code_slots_file[cs],0 );
  1877. #endif
  1878. #ifdef TRACE
  1879.                     if (call_trace) {
  1880.                         if (code_slots[cs])
  1881.                             printf("calling %s (tos %d -> ",
  1882.                               code_slots[cs],cur_stackptr);
  1883.                         else 
  1884.                             printf("calling %s (tos %d -> ",
  1885.                               "compiler_generated_procedure", cur_stackptr);
  1886.                     }
  1887. #endif
  1888.                     cur_code = code_segments[cs];
  1889.                     /* reserve space for local variables */
  1890. #ifdef ALIGN_WORD
  1891.                     val1 = get_int((int *)(cur_code + code_seglen[cs] 
  1892.                       - sizeof(int) - 1));
  1893. #else
  1894.                     val1 = *(int *)(cur_code+code_seglen[cs] - sizeof(int) - 1);
  1895. #endif
  1896.                     /* reserve space for locals */
  1897.                     if (val1 < 0)
  1898.                         raise(SYSTEM_ERROR, "Negative size of locals");
  1899.                     else
  1900.                         cur_stackptr += val1;
  1901.                     PUSH(sfp);
  1902.                     PUSH(old_cs);
  1903.                     PUSH(lin);
  1904.                     PUSH(ip);
  1905.                     sfp = cur_stackptr + 1;
  1906.                     ip = 2;
  1907.                     /* copy relay set */
  1908.                     val2 = *(++ptr) * 2;/* length of relay set */
  1909.                     for (i = 1; i <= val2; i++)            /* copy relay set */
  1910.                         PUSH(*++ptr);
  1911. #ifdef TRACE
  1912.                     if(call_trace)
  1913.                         printf("%d)\n",cur_stackptr);
  1914. #endif
  1915.                 }
  1916.             }
  1917.             break;
  1918.  
  1919.         case I_CALL_PREDEF:
  1920.             operation = GET_BYTE;
  1921.             predef();
  1922.             break;
  1923.  
  1924. #ifdef INTERFACE
  1925.         case I_CALL_INTERFACE: 
  1926.             interface(GET_WORD);
  1927.             break;
  1928. #endif
  1929.  
  1930.         case I_CASE_B:
  1931.         case I_CASE_W:
  1932.         case I_CASE_L:
  1933.             POP(value);
  1934.             nb = GET_WORD;
  1935.             jump = GET_WORD;
  1936.             for (i = 1; i <= nb; i++) {
  1937.                 val_high = GET_WORD;
  1938.                 if (value < val_high)
  1939.                     break;
  1940.                 jump = GET_WORD;
  1941.             }
  1942.             ip = jump;
  1943.             break;
  1944.  
  1945.         case I_RETURN_B:
  1946.         case I_RETURN_W:
  1947.             POP(value);
  1948.             cur_stack[sfp + GET_WORD] = value;
  1949.             break;
  1950.  
  1951.         case I_RETURN_L:
  1952.             POPL(lvalue);
  1953.             *(LONG(&cur_stack[sfp + GET_WORD])) = lvalue;
  1954.             break;
  1955.  
  1956.         case I_RETURN_A:
  1957.             POP_ADDR(bse, off);
  1958.             sp = GET_WORD + sfp;
  1959.             cur_stack[sp] = bse;
  1960.             cur_stack[sp + 1] = off;
  1961.             break;
  1962.  
  1963.         case I_RETURN_STRUC:
  1964.             sp = GET_WORD + sfp;
  1965.             POP_ADDR(bse, off);/*     type */
  1966.             ptr = ADDR(bse, off);
  1967.             POP_ADDR(bas2, off2);/* value */
  1968.             ptr2 = ADDR(bas2, off2);
  1969.  
  1970.             val1 = TYPE(ptr);/* type of type */
  1971.             val2 = SIZE(ptr);
  1972.             allocate(val2, &bas1, &off1, &ptr1);
  1973.             cur_stack[sp] = bas1;
  1974.             cur_stack[sp + 1] = off1;
  1975.  
  1976.             for (i = 0; i < val2; i++)
  1977.                 *ptr1++ = *ptr2++;
  1978.  
  1979.             switch(val1) {
  1980.             case TT_U_ARRAY:
  1981.             case TT_C_ARRAY:
  1982.             case TT_S_ARRAY:
  1983.             case TT_D_ARRAY:
  1984.                 if (bse >= heap_base) {/* non static template */
  1985.                     /* create new type template */
  1986.                     /* size of template */
  1987.                     val2 = *(ptr -  WORDS_HDR) - WORDS_HDR;
  1988.                     allocate(val2, &bse, &off, &ptr1);
  1989.  
  1990.                     for (i = 0; i < val2; i++)
  1991.                         *ptr1++ = *ptr++;
  1992.                 }
  1993.                 cur_stack[sp + 2] = bse;
  1994.                 cur_stack[sp + 3] = off;
  1995.                 break;
  1996.  
  1997.             case TT_RECORD:
  1998.             case TT_U_RECORD:
  1999.             case TT_C_RECORD:
  2000.             case TT_D_RECORD:
  2001.             case TT_V_RECORD:
  2002.                 break;
  2003.             }
  2004.             break;
  2005.  
  2006.         case I_END_FOR_LOOP_B:
  2007.         case I_END_FOR_LOOP_W:
  2008.         case I_END_FOR_LOOP_L:
  2009.             val2 = GET_WORD;
  2010.             off = TOS;
  2011.             bse = TOSM(1);
  2012.             lim = TOSM(2);
  2013.             value = *ADDR(bse, off);
  2014.             if (value >= lim) {
  2015.                 POP_ADDR(bse, off);
  2016.                 POP(val1);
  2017.             }
  2018.             else {
  2019.                 *ADDR(bse, off) = value + 1;
  2020.                 ip = val2;
  2021.             }
  2022.             break;
  2023.  
  2024.         case I_END_FORREV_LOOP_B:
  2025.         case I_END_FORREV_LOOP_W:
  2026.         case I_END_FORREV_LOOP_L:
  2027.             val2 = GET_WORD;
  2028.             off = TOS;
  2029.             bse = TOSM(1);
  2030.             lim = TOSM(2);
  2031.             value = *ADDR(bse, off);
  2032.             if (value <= lim) {
  2033.                 POP_ADDR(bse, off);
  2034.                 POP(val1);
  2035.             }
  2036.             else {
  2037.                 *ADDR(bse, off) = value - 1;
  2038.                 ip = val2;
  2039.             }
  2040.             break;
  2041.  
  2042.         case I_JUMP:
  2043.             val2 = GET_WORD;
  2044.             ip = val2;
  2045.             break;
  2046.  
  2047.         case I_JUMP_IF_FALSE:
  2048.             val2 = GET_WORD;
  2049.             POP(value);
  2050.             if (BOOL(value) == 0)
  2051.                 ip = val2;
  2052.             break;
  2053.  
  2054.         case I_JUMP_IF_TRUE:
  2055.             val2 = GET_WORD;
  2056.             POP(value);
  2057.             if (BOOL(value) == 1)
  2058.                 ip = val2;
  2059.             break;
  2060.  
  2061.         case I_JUMP_IF_GREATER:
  2062.             val2 = GET_WORD;
  2063.             POP(value);
  2064.             if (value == 2)
  2065.                 ip = val2;
  2066.             break;
  2067.  
  2068.         case I_JUMP_IF_GREATER_OR_EQUAL:
  2069.             val2 = GET_WORD;
  2070.             POP(value);
  2071.             if (value >= 1)
  2072.                 ip = val2;
  2073.             break;
  2074.  
  2075.         case I_JUMP_IF_LESS:
  2076.             val2 = GET_WORD;
  2077.             POP(value);
  2078.             if (value == 0)
  2079.                 ip = val2;
  2080.             break;
  2081.  
  2082.         case I_JUMP_IF_LESS_OR_EQUAL:
  2083.             val2 = GET_WORD;
  2084.             POP(value);
  2085.             if (value <= 1)
  2086.                 ip = val2;
  2087.             break;
  2088.  
  2089.             /* Miscellanous Instructions */
  2090.  
  2091.         case I_LOAD_EXCEPTION_REGISTER:
  2092.             exr = GET_WORD;
  2093.             raise_cs = cs;
  2094.             raise_lin = lin;
  2095.             raise_reason = "Instruction";
  2096.             break;
  2097.  
  2098.         case I_INSTALL_HANDLER:
  2099.             BLOCK_FRAME->bf_handler = GET_WORD;
  2100.             break;
  2101.  
  2102.         case I_RAISE:
  2103.             raise(exr, "");
  2104.             break;
  2105.  
  2106.         case I_RESTORE_STACK_POINTER:
  2107.             sp = GET_WORD + sfp;
  2108.             sp = cur_stack[sp];
  2109.             cur_stackptr = sp;
  2110.             break;
  2111.  
  2112.         case I_SAVE_STACK_POINTER:
  2113.             sp = GET_WORD + sfp;
  2114.             cur_stack[sp] = cur_stackptr;
  2115.             break;
  2116.  
  2117.         case I_STMT:
  2118.             lin = GET_WORD;
  2119. #ifdef TRACE
  2120.             if (line_trace)
  2121.                 printf("at line %d (tos %d)\n",lin,cur_stackptr);
  2122. #endif
  2123. #ifdef GWUMON
  2124.             CWK_SET_TASK_LINE(lin, 1);
  2125. #endif
  2126.             break;
  2127.  
  2128.         case I_SUBSCRIPT:
  2129.             subscript();
  2130.             break;
  2131.  
  2132.         case I_SELECT:
  2133.             value = GET_WORD; /* retrieve parameter for select */
  2134.             rselect(value);
  2135.             break;
  2136.  
  2137.         case I_TEST_EXCEPTION_REGISTER:
  2138.             PUSH(exr == GET_WORD);
  2139.             break;
  2140.  
  2141.         case I_TYPE_LOCAL:
  2142.             GET_GAD(bse, off);
  2143.             type_elaborate(1,bse,off);
  2144.             break;
  2145.  
  2146.         case I_TYPE_GLOBAL:
  2147.             GET_GAD(bse, off);
  2148.             type_elaborate(0,bse,off);
  2149.             break;
  2150.  
  2151.         case I_SUBPROGRAM:
  2152.             GET_LAD(bse,off);
  2153.             subprogram(bse,off);
  2154.             break;
  2155.  
  2156.         case I_CHECK_REC_SUBTYPE:
  2157.             POP_ADDR(bse, off);
  2158.             check_subtype_with_discr (ADDR (bse, off), NULL_INT);
  2159.             break;
  2160.  
  2161.         default:
  2162.             raise(SYSTEM_ERROR, "Bad opcode");
  2163.  
  2164.         }            /* end switch on operation code */
  2165.     }                /* end loop through instructions */
  2166. }                    /* end main_loop procedure */
  2167.  
  2168. #ifdef DEBUG_INT
  2169. static int get_word()            /*;get_word*/
  2170. {
  2171.     int     w;
  2172.     w = *((int *)(cur_code + ip));
  2173.     ip += sizeof(int);
  2174.     return w;
  2175. }
  2176.  
  2177. #endif
  2178. #ifdef ALIGN_WORD
  2179. int get_int(int *n)                                        /*;get_int*/
  2180. {
  2181.     register int i;
  2182.     int v;
  2183.     register char *sp,*tp;
  2184.  
  2185.     sp = (char *) n;
  2186.     tp = (char *) &v;
  2187.     for (i=0; i<sizeof(int); i++) *tp++ = *sp++;
  2188.     return v;
  2189. }
  2190.  
  2191. long get_long(long *n)                                /*;get_long*/
  2192. {
  2193.     register int i;
  2194.     long v;
  2195.     register char *sp,*tp;
  2196.  
  2197.     sp = (char *) n;
  2198.     tp = (char *) &v;
  2199.     for (i=0; i<sizeof(long); i++) *tp++ = *sp++;
  2200.     return v;
  2201. }
  2202.  
  2203. static int get_word()                                    /*;get_word*/
  2204. {
  2205.     /* if integers must be aligned, get byte by byte */
  2206.     int w,i;
  2207.     char *sp,*tp;
  2208.     sp = (char *) ((int *)(cur_code+ip));
  2209.     ip += sizeof(int);
  2210.     tp = (char *) &w;
  2211.     for (i=0; i<sizeof(int); i++)
  2212.         *tp++ = *sp++;
  2213.     return w;
  2214. }
  2215. #endif
  2216.  
  2217. int allocate_new_heap()                                /*;allocate_new_heap*/
  2218. {
  2219.     /* This procedure attempts to allocate a new heap.
  2220.      * It returns 1 if it succeeds, 0 otherwise.
  2221.      * The size of the heap is defined by max_mem (see config.h).
  2222.      */
  2223.  
  2224.     char *temporary;
  2225.  
  2226.     /* First tries to reallocate data_segments.  */
  2227.     temporary = realloc(data_segments,
  2228.       (data_segments_dim + 2) * sizeof(char **));
  2229.     if(temporary == (char *)0) return 0;
  2230.     data_segments = (int **)temporary;
  2231.  
  2232.     /* Now tries to allocate the new heap. */
  2233.     temporary = malloc((unsigned) max_mem * sizeof(int));
  2234.     if(temporary == (char *)0) return 0;
  2235.  
  2236.     /* Everything ok: increment data_segments_dim and set heap_base,
  2237.      * heap_addr and heap_next.
  2238.      */
  2239.     heap_addr = (int *)temporary;
  2240.     heap_base = ++data_segments_dim;
  2241.     data_segments[heap_base] = heap_addr;
  2242.     heap_next = heap_addr;
  2243. #ifdef DEBUG_STORES
  2244.     heap_store_addr = heap_addr;
  2245. #endif
  2246.     return 1;
  2247. }
  2248.  
  2249. #ifdef DEBUG_INT
  2250. static void zbreak(int before)                                        /*;zbreak*/
  2251. {
  2252.     break_point = before;
  2253. }
  2254. #endif
  2255.